perm filename SMOOTH[1,BGB] blob
sn#020872 filedate 1973-02-23 generic text, type T, neo UTF8
00100 SUBR(BABYKILLER)LEVEL---------------------------------------------
00200 BEGIN BABYKILLER; -BGB- 28 DEC 1972.
00300 ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00400 SKIPN FLGBK↔POP1J
00500 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
00600 ;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
00700 GO L3
00800 ;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00900 L1: NCNT 0,PG↔LACM
01000 CAIL =10↔GO L3
01100
01200 ;RELEASE VIC NODES OF THE POLYGON.
01300 SON E0,PG
01400 LAC E1,E0
01500 L2: CCW E2,E1
01600 CALL(KILL,E1)
01700 CAMN E2,E0↔GO .+3
01800 LAC E1,E2↔GO L2
01900
02000 ;KILL A BABY POLYGON.
02100 CAR Q,(PG)↔CDR R,(PG)
02200 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02300 CALL(KILL,PG)
02400 SKIPA PG,R ;CCW FROM OUT OF THE GRAVE.
02500
02600 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02700 L3: CCW PG,PG↔CAME PG,PG0↔GO L1
02800 POP1J
02900
03000 BEND;1/6/73------------------------------------------------------
00100 SUBR(KLPOLY)POLYGON-----------------------------------------------
00200 BEGIN KLPOLY;KILL POLYGON RETURN CCW(PGN) - BGB - 7 JANUARY 1973.
00300 ACCUMULATORS{PG,E0,E1,E2,Q,R}
00400 LAC PG,ARG1
00500
00600 ;RELEASE VIC NODES OF THE POLYGON.
00700
00800 SON E0,PG
00900 LAC E1,E0
01000 L1: CCW E2,E1
01100 CALL(KILL,E1)
01200 CAMN E2,E0↔GO .+3
01300 LAC E1,E2↔GO L1
01400
01500 ;RING OUT & KILL POLYGON NODE,
01600
01700 NGON Q,PG↔PGON R,PG↔JUMPE R,L2
01800 NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
01900 EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
01910 ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
02000
02100 L2: CAR Q,(PG)↔CDR R,(PG)
02200 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02300 CALL(KILL,PG)
02400
02500 ;DOES DAD NEED A NEW FIRST SON.
02600
02700 DAD 1,R
02800 CAMN PG,R↔SETZ R,
02900 SON 0,1↔CAMN 0,PG↔SON. R,1
03000
03100 ;RETURN PGON CCW FROM OUT OF THE GRAVE.
03200 LAC 1,R
03300 POP1J
03400
03500 BEND;1/8/73------------------------------------------------------
00100 SUBR(SMOOTH)LEVEL-------------------------------------------------
00200 BEGIN SMOOTH; -BGB- 6 DEC 1972.
00300 ACCUMULATORS{V1,V2,PG,E0,E1,E2}
00400 SKIPN FLGARC↔POP1J ;MAKE ARC ENABLED ?
00500 LAC 1,ARG1
00600 SON PG,1↔SKIPN PG↔POP1J
00700
00800 ;POLYGON INITIALIZATION.
00850
00900 L1: DAC PG,PGSAVE#
01000 SON V1,PG↔DAC V1,E0SAVE# ;UPPER MOST LEFT VERTEX.
01200 ARC V2,PG ;LOWER MOST RIGHT VERTEX.
01300 TESTZ V2,ARCBIT↔POP1J ;END OF LEVEL'S POLYGON RING.
01400
01500 ;CREATE ARC NODES AT POLYGON'S EXTREME CORNERS.
01550
01600 SETQ(ARC2,{MAKE,[VBIT+ARCBIT+VREL]})
01800 LAC RC(V2)↔DAC RC(1)↔ARC. 1,V2↔ARC. V2,1
02100 SETQ(ARC1,{MAKE,[VBIT+ARCBIT+VREL]})
02300 LAC RC(V1)↔DAC RC(1)↔ARC. 1,V1↔ARC. V1,1
02500
02600 LAC 2,ARC2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
02700 PGON. PG,1↔PGON. PG,2↔ARC. 1,PG
02800
02900 ;CALL FOR CREATION OF THE INTERMEDIATE ARC NODES.
03000 SETZM AVCNT
03100 CALL(MKARCS,ARC1,ARC2)
03200 CALL(MKARCS,ARC2,ARC1)
03300
03400 ;KILL TWO-SIDED ARC-POLYGONS AND ADVANCE TO NEXT POLYGON.
03500 SKIPN AVCNT↔GO[
03600 SETQ(PG,{KLPOLY,PGSAVE})
03700 JUMPN PG,L1↔POP1J]
03800 LAC PG,PGSAVE↔CCW PG,PG↔GO L1
03900
04000 LIT
04050 DECLARE{ARC1,ARC2}
04100 BEND;1/9/73-------------------------------------------------------
04200
04300 DECLARE{AVCNT} ;ARC-VERTEX COUNT.
00100 SUBR(ARCONT)LEVEL-------------------------------------------------
00200 BEGIN ARCONT;ARC CONTRAST - BGB - 21 JANUARY 1973.
00300 ACCUMULATORS{QNS,QEW,A1,A2,V1,V2,PG,PG0,A0}
00400
00500 ;FOR ALL THE ARCS OF THIS LEVEL.
00600 LAC 1,ARG1
00700 SON PG,1↔DAC PG,PG0 ;FIRST POLYGON.
00800 L1: ARC A2,PG↔DAC A2,A0 ;FIRST ARC.
00900 L2: LAC A1,A2↔ARC V1,A1
01000 CCW A2,A1↔ARC V2,A2
01100
01200 ;ACCUMULATE VECTOR CONTRAST,,LENGTH ALONG THE ARC.
01300 SETZB QNS,QEW
01400 L3: TESTZ V1,NORBIT+SOUBIT↔GO[
01500 ADD QNS,6(V1)↔GO .+2]
01600 ADD QEW,6(V1)
01700 CCW V1,V1
01800 CAME V1,V2↔GO L3
01900
02000 ;COMPUTE ARC CONTRAST: SIN↑2*VERTICAL + COS↑2*HORIZONTAL.
02100 CAR 0,QNS↔FSC 0,233
02200 CDR 1,QNS↔FSC 1,233↔FDVR 0,1
02300 HLLZ 1,6(A1)↔FMPR 0,1↔DAC 0,QNS
02400 CAR 0,QEW↔FSC 0,233
02500 CDR 1,QEW↔FSC 1,233↔FDVR 0,1
02600 HRLZ 1,6(A1)↔FMPR 0,1↔FADR 0,QNS
02700 FIX 0,233000↔CNTRS. 0,A1
02800
02900 CAME A2,A0↔GO L2 ;LAST ARC OF THE POLYGON ?
03000 CCW PG,PG
03100 CAME PG,PG0↔GO L1 ;LAST POLYGON OF THE LEVEL ?
03200 POP1J
03300 BEND;1/21/73------------------------------------------------------
00100 SUBR(SQRT)--------------------------------------------------------
00200 BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT - BGB - TRADITIONAL.
00300 A←0 ↔ B←1 ↔ C←2
00400 LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
00500
00600 ;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
00700 ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
00800 ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
00900 DAP B,L↔LSH B,-=35 ;USE THAT ODD BIT.
01000 ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
01100
01200 ;LINEAR APPROXIMATION TO SQRT(F).
01300 DAC C,A
01400 FMP C,[0.8125↔0.578125](B)
01500 FAD C,[0.302734↔0.421875](B)
01600
01700 ;TWO ITERATIONS OF NEWTON'S METHOD.
01800 LAC B,A
01900 FDV B,C↔FAD C,B↔FSC C,-1
02000 FDV A,C↔FADR A,C
02100 L: FSC A,0↔LAC 1,A↔POP P,2
02200 POP1J↔LIT
02300 BEND;28/12/72-----------------------------------------------------
00100 SUBR(MKARCS)V1,V2-------------------------------------------------
00200 BEGIN MKARCS;MAKE ARCS - FROM U1 CCW TO U2 - BGB - AUG 1972.
00300 ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00400 LAC V1,ARG2↔LAC V2,ARG1
00500 ;CHECK FOR TRIVAIL CASE.
00600 L0: ARC U1,V1↔ARC U2,V2
00700 CCW 0,U1↔CAMN 0,U2↔GO L3
00800
00900 ;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01000 ROW A,V1↔FLO A, ; A ← Y1.
01100 COL B,V2↔FLO B, ; B ← X2.
01200 COL C,V1↔FLO C, ; C ← X1.
01300 ROW D,V2↔FLO D, ; D ← Y2.
01400 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
01500 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
01600 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
01700 LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01800 CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
01900 LAC 0,A↔FMPR 0,A↔HLLM 0,6(V1)
02000 LAC 0,B↔FMPR 0,B↔HLRM 0,6(V1)
02100
02200 ;SET 'EM UP FOR AN ARC PASS.
02300 ARC U1,V1↔ARC U2,V2
02400 SETZM DMAX#↔SETZM DMIN#
02500 SETZM VMAX#↔SETZM VMIN#
02600 SETZM MAXCON#
02700 ;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
02800 L1: CCW U1,U1↔CAMN U1,U2↔GO L2
02900 COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
03000 FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
03100 CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
03200 CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
03300 ;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
03400 CNTRST 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
03500
03600 ;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
03700 L2: LAC U,VMIN↔LACM DMIN
03800 CAMGE DMAX↔LAC U,VMAX
03900 CAMGE DMAX↔LAC DMAX
04000 LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
04100 ;OLDE ESPLIT.
04200 SETQ(V,{MAKE,[VBIT+ARCBIT+VREL]})↔AOS AVCNT
04300 ARC. U,V↔ARC. V,U
04400 LAC RC(U)↔DAC RC(V)↔PGON 0,U↔PGON. 0,V
04500 CCW. V,V1↔CW. V1,V
04600 CCW. V2,V↔CW. V,V2
04700 LAC V2,V↔GO L0
04800
04900 ;ADVANCE CCW AN ARC-EDGE OR EXIT.
05000 L3: CAMN V2,ARG1↔POP2J
05100 LAC V1,V2↔CCW V2,V2↔GO L0
05200 BEND;28/12/72-----------------------------------------------------
00100 SUBR(FARCL)PGON---------------------------------------------------
00200 BEGIN FARCL; FIT ARCS LINEAR.
00300 X←←1
00400 ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
00500
00600 ;Clear the Locus of all the Arc Vertices.
00700 LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
00800 CCW V1,E ↔ SETZM RC(V1)
00900 CCW E,V1 ↔ CAME E,E0↔JRST .-4
01000
01100 ;Advance along Polygon.
01200 CW V2,E
01300 L1: LAC V1,V2↔CCW V2,E
01400 ARC U1,V1↔ARC U2,V2
01500 CW U1,U1↔CW U1,U1
01600 CW U1,U1↔CW U1,U1
01700 CW U1,U1↔CW U1,U1
01800 CCW U2,U2↔CCW U2,U2
01900 CCW U2,U2↔CCW U2,U2
02000 CCW U2,U2↔CCW U2,U2
02100
02200 ;Arc Scan Initialization.
02300 LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
02400 ;Advance along VIC within the ARC.
02500 L2: CCW U1,U1↔CCW U1,U1
02600 ;Accumulate a Point.
02700 CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
02800 FAD SX,X ↔ FAD SY,Y
02900 LAC X ↔ FMP Y ↔ FAD XY,0
03000 FMP X,X ↔ FAD XX,X
03100 FMP Y,Y ↔ FAD YY,Y
03200 CAME U1,U2↔AOJA N,L2↔AOS N
00100 ;COMPUTE SYMMETRIC LEAST SQUARES LINE COEFFICIENTS.
00200 ; Q ← N*XY - SY*SX.
00300 ; A ← Q + SY*SY - N*YY.
00400 ; B ← Q + SX*SX - N*XX.
00500 ; C ← SX*YY + SY*XX - XY*(SX+SY).
00600
00700 L3: LAC 2,SX↔FMP 2,YY
00800 LAC 0,SY↔FMP 0,XX↔FAD 2,0
00900 LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
01000
01100 FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N ;all the N terms.
01200 LAC SX↔FMP SY↔FSB XY,0 ;Q in XY.
01300
01400 FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
01500 FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
01600
01700 FMP SY,SY↔FMP SX,SX↔FAD SX,SY
01800 SLACI(1.0)↔FDVR SX↔DAC QQQQ# ;PSEUDO NORMALIZATION.
01900
02000 ;SOLVE FOR THE LOCII WHERE PERPENDICULARS DROPPED FROM
02100 ;THE ARC-EDGE HIT THE FITTED LINE.
02200 ; Q ← 1/(A*A + B*B).
02300 ; D ← (B*X1 - A*Y1).
02400 ; X ← (B*D - A*C)*Q.
02500 ; Y ←-(A*D + B*C)*Q.
02600
02700 L4: ARC U1,V1
02800 CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
02900 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03000 FMP X,BBBB↔FMP Y,AAAA
03100 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
03200 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
03300 DIP Y,X↔ADDM X,RC(V1)
03400
03500 ARC U2,V2
03600 CDR X,RC(U2)↔FLO X,↔CAR Y,RC(U2)↔FLO Y,
03700 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03800 FMP X,BBBB↔FMP Y,AAAA
03900 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
04000 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
04100 DIP Y,X↔ADDM X,RC(V2)
04200
04300 CCW E,V2↔CAME E,E0↔JRST L1
04400 LAC 12,AC12↔POP1J
04500 BEND;1/6/73-------------------------------------------------------